perm filename CHS1.F4[1,VDS] blob
sn#113818 filedate 1974-07-31 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00026 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 C MAIN PROGRAM -- 'LOOK-UP'
C00018 00003 SUBROUTINE OUTPUT (SKIP)
C00030 00004 SUBROUTINE UPDATE
C00035 00005 SUBROUTINE MESAGE
C00038 00006 SUBROUTINE RESET
C00041 00007 SUBROUTINE CLEARS
C00044 00008 SUBROUTINE SETUP (*)
C00051 00009 SUBROUTINE CLEAR
C00056 00010 SUBROUTINE RPAREN
C00059 00011 SUBROUTINE EQUAL
C00061 00012 SUBROUTINE SEMI
C00064 00013 SUBROUTINE SIGN
C00067 00014 SUBROUTINE FUNCTN
C00070 00015 SUBROUTINE COLAPS (*)
C00073 00016 SUBROUTINE COMBIN (A, OPER, *)
C00078 00017 SUBROUTINE CLEARX
C00081 00018 SUBROUTINE ENTRY
C00086 00019 SUBROUTINE DIGIT
C00089 00020 SUBROUTINE DECPT
C00093 00021 SUBROUTINE CORECT
C00097 00022 SUBROUTINE RECALL
C00101 00023 SUBROUTINE STORE
C00105 00024 SUBROUTINE REG (RN)
C00108 00025 SUBROUTINE FINDN (K, KMAX, RN)
C00112 00026 SUBROUTINE FIXN
C00115 ENDMK
C⊗;
C MAIN PROGRAM -- 'LOOK-UP'
C DATE OF LAST CHANGE - 740709
IMPLICIT INTEGER (A-Z)
C- REAL Y
LOGICAL START, READ, NEXT, FIXFLG, TRUE
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DATA TRUE/.TRUE./
10 DO 20 I=2,21
DO 20 J=1,17
R(I,J)=0
20 R(I,2)=15
R(21,1)=15
R(21,2)=1
R(21,3)=5
R(21,17)=1
C *** REGISTERS ARE ALLOCATED AS FOLLOWS: R(1)="PI", R(2)="A",
C R(3)="LST X", R(4)="LST Y", R(5)="R0", ..., R(20)="R15",
C R(21)="HIGHEST REG NO. AVAILABLE"
C
C SIZE = NO. OF KEYS ON KEYBOARD (SEE DECODER BELOW)
SIZE=44
C *** CONTROL PARAMETERS
C NEQNS = NO. OF TESTS TO BE RUN
C- READ = SWITCH FOR INPUT MODE (F = RANDOM)
C SWITCH = OUTPUT CONTROL (0 -> NORMAL, 1 -> SHORT)
C FIXFLG = 'DISPLAY' CONTROL (T = FIX MODE)
C FIX = NUMBER OF DECIMAL DIGITS IN FIX MODE (0-9)
C SCI = NUMBER OF DECIMAL DIGITS IN SCI MODE (0-9)
C NKEYS = NO. OF KEY-STROKES PER TEST
C IY = RANDOM NO.
C
NEQNS=100
C- READ=.TRUE.
SWITCH=2
FIXFLG=.TRUE.
FIX=2
SCI=5
C
TYPE 1000
ACCEPT 1011, START
IF (START) GO TO 40
TYPE 1001
ACCEPT 1012, NEQNS
C- TYPE 1002
C- ACCEPT 1011, READ
C- READ=.NOT.READ
C- IF (READ) GO TO 30
C- TYPE 1003
C- ACCEPT 1013, NKEYS, IY
30 TYPE 1004
ACCEPT 1012, SWITCH
TYPE 1008
ACCEPT 1011, START
IF (START) GO TO 40
TYPE 1009
ACCEPT 1011, FIXFLG
TYPE 1010
ACCEPT 1013, FIX, SCI
C CONSIDER 'NEQNS' EQUATIONS
40 DO 340 TEST=1,NEQNS
ERROR=0
OLD=1
DO 50 II=1,50
INPUT(II)=15
50 EXPR(II)=15
CALL CLEAR
TYPE 1015, TEST
C- IF (READ) GO TO 90
C- 60 DO 80 II=1,NKEYS
C- 70 CALL RANDOM (IY, Y, 0)
C- JJ=(SIZE-1)*Y+1.5
C- IF (JJ.EQ.15.OR.JJ.EQ.29.OR.JJ.EQ.30) GO TO 70
C- 80 INPUT(II)=JJ
90 CALL OUTPUT (-1)
KEY=0
C OBTAIN NEXT KEY-CODE
100 CALL CONTRL (TRUE)
C DECODE KEY-CODE
110 IF (NEXT) NEXT=.FALSE.
IF (CODE.LE.12) GO TO 130
IF (CODE.EQ.13 .OR. CODE.EQ.14) GO TO 140
IF (CODE.GT.15.AND.CODE.LT.20.AND.CODE.NE.18) GO TO 150
IF (CODE.EQ.18) GO TO 160
IF (CODE.EQ.20) GO TO 170
IF (CODE.EQ.21) GO TO 180
IF (CODE.EQ.22) GO TO 190
IF (CODE.GT.22 .AND. CODE.LT.26 .OR.
* CODE.EQ.38 .OR. CODE.EQ.39) GO TO 200
IF (CODE.EQ.26) GO TO 210
IF (CODE.EQ.27) GO TO 220
IF (CODE.EQ.28) GO TO 230
IF (CODE.EQ.31) GO TO 240
IF (CODE.EQ.32) GO TO 250
IF (CODE.EQ.33) GO TO 260
IF (CODE.EQ.34) GO TO 270
IF (CODE.EQ.35) GO TO 280
IF (CODE.EQ.36) GO TO 290
IF (CODE.EQ.37) GO TO 300
IF (CODE.GT.39 .AND. CODE.LT.44) GO TO 150
IF (CODE.EQ.44) GO TO 180
IF (CODE.EQ.15.OR.CODE.EQ.29.OR.CODE.EQ.30) GO TO 320
IF (CODE.EQ.99) GO TO 340
IF (CODE.EQ.999) GO TO 10
IF (CODE.GT.SIZE) GO TO 120
C KEY-CODE ERROR
120 ERROR=17
GO TO 310
C CALL KEY ROUTINE
130 CALL ENTRY
GO TO 310
140 CALL SIGN
GO TO 310
150 CALL OPRATR
GO TO 310
160 CALL LPAREN
GO TO 310
170 CALL RPAREN
GO TO 310
180 CALL FUNCTN
GO TO 310
190 CALL EQUAL
GO TO 310
200 CALL RECALL
GO TO 310
210 CALL CLEAR
GO TO 310
220 CALL CLEARX
GO TO 310
230 CALL CORECT
GO TO 310
240 CALL STORE
GO TO 310
250 CALL FIXN
GO TO 310
260 CALL SCIN
GO TO 310
270 CALL IMEDEX
GO TO 310
280 CALL EXCH
GO TO 310
290 CALL SEMI
GO TO 310
300 CALL COMMA
C PRINT EXPRESSION, STACK, VARIABLES
310 IF (ERROR.NE.0) CALL MESAGE
IF (ERROR.NE.0) GO TO 330
320 IF (KEY.LT.NKEYS) GO TO 100
GO TO 340
330 TYPE 1016
340 CONTINUE
STOP
1000 FORMAT (///' THE STANDARD CONTROL SETTINGS ARE:'
* /' EXIT AFTER 100 EQUATIONS'
* /' PRODUCE ''DISPLAY'' OUTPUT'
* /' DISPLAY IN FIX MODE W/ FIX=2 & SCI=5'
* //' THESE ARE OKAY. (T OR F)'/)
C-↑↑↑* /' ACCEPT KEYSTROKES FROM TTY'
1001 FORMAT (/' HOW MANY EQUATIONS ARE YOU GOING TO TRY? (NN)'/)
C1002 FORMAT (/' THE KEYSTROKES ARE TO BE GENERATED RANDOMLY.',
C- * ' (T OR F)'/)
C1003 FORMAT (/' ENTER THE NUMBER OF KEYSTROKES TO BE GENERATED '
C- * /' AND AN INITIAL RANDOM NUMBER. (NN <SP> MM)'/)
1004 FORMAT (/' ENTER CODE FOR DESIRED OUTPUT: 0 = LONG'/32X,
* ' 1 = SHORT'/33X,'2 = DISPLAY ONLY'/)
1008 FORMAT (/' THE STANDARD DISPLAY SETTINGS ARE WANTED.',
* ' (T OR F)'/)
1009 FORMAT (/' FIX MODE DISPLAY IS WANTED INITIALLY. (T OR F)'/)
1010 FORMAT (/' ENTER NUMBER OF DECIMAL DIGITS DESIRED IN FIX'
* /' AND SCI MODES, RESPECTIVELY. (N <SP> M)'/)
1011 FORMAT (L1)
1012 FORMAT (I)
1013 FORMAT (2I)
1015 FORMAT ('1 TEST NO.',I3/)
1016 FORMAT (/' ATTEMPT TO ENTER KEY WHILE IN ERROR CONDITION',
* ' HAS TERMINATED THIS EQUATION'/)
END
C
C
C
C
C
C
C
C
C
C
BLOCK DATA
C DATE OF LAST CHANGE - 740310
IMPLICIT INTEGER (A-Z)
LOGICAL JUMP, NEXT, MVO, SUM
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DATA P /6*0/, OP /6*0/, D /16*13/, X /102*13/,
* JUMP, NEXT, MVO, SUM /4*.FALSE./, NKEYS /100/,
* R(1,1),R(1,2),R(1,3),R(1,4),R(1,5),R(1,6),R(1,7),R(1,8),
* R(1,9),R(1,10),R(1,11),R(1,12),R(1,13),R(1,14),R(1,15),
* R(1,16),R(1,17) /15,3,1,4,1,5,9,2,6,5,3,5,9,0,15,0,0/
END
C
C
C
C
C
C
C
C
C
C
C- SUBROUTINE RANDOM (IY, Y, INDEX)
C- IY=IY*314159269+453806245
C- IF (IY.LT.0) IY=IY+2147483647+1
C- Y=IY
C- Y=Y*4.656613E-10
C- RETURN
C- END
SUBROUTINE OUTPUT (SKIP)
C DATE OF LAST CHANGE - 740310
IMPLICIT INTEGER (A-Z)
INTEGER*2 CHAR(44), STROKE(50), SIGN(6), ESN(6),
* DISPLY(16), REG(17)
LOGICAL EEX, DP, FIXFLG, MVO, SUM
REAL*8 NAME(3)
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
2 /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
3 /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
4 /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DATA CHAR( 1),CHAR( 2),CHAR( 3),CHAR( 4)/' 1',' 2',' 3',' 4'/,
2 CHAR( 5),CHAR( 6),CHAR( 7),CHAR( 8)/' 5',' 6',' 7',' 8'/,
3 CHAR( 9),CHAR(10),CHAR(11),CHAR(12)/' 9',' 0',' .','EE'/,
4 CHAR(13),CHAR(14),CHAR(15),CHAR(16)/' -',' +',' ',' /'/,
5 CHAR(17),CHAR(18),CHAR(19),CHAR(20)/' *',' (','**',' )'/,
6 CHAR(21),CHAR(22),CHAR(23),CHAR(24)/'AB',' =',' A','PI'/,
7 CHAR(25),CHAR(26),CHAR(27),CHAR(28)/' R','CL','CX','CO'/,
8 CHAR(29),CHAR(30),CHAR(31),CHAR(32)/' E','SV','->','FX'/,
9 CHAR(33),CHAR(34),CHAR(35),CHAR(36)/'SN','IX','XC',' ;'/,
A CHAR(37),CHAR(38),CHAR(39),CHAR(40)/' ,','LX','LY',' ='/,
B CHAR(41),CHAR(42),CHAR(43),CHAR(44)/' #',' >',' <','MG'/
DATA NAME /' A =', 'LAST X =','LAST Y ='/
C VARIOUS VALUES OF 'SKIP' GIVE: -1 → CLEAR EXPRESSION
C 0 → LONG OUTPUT
C 1 → SHORT OUTPUT
C 2 → DISPLAY ONLY
IF (SKIP.GE.0) GO TO 20
DO 10 I=1,50
10 STROKE(I)=CHAR(15)
RETURN
20 DO 30 I=OLD,KEY
J=EXPR(I)
IF (J.EQ.0) J=10
30 STROKE(I)=CHAR(J)
TYPE 1000, (STROKE(I),I=1,KEY)
OLD=KEY+1
IF (SKIP.EQ.2) GO TO 70
DO 60 I=1,6
J=X(I,1)
IF (J.EQ.0) J=15
SIGN(I)=CHAR(J)
K=X(I,15)
IF (K.EQ.0) K=15
60 ESN(I)=CHAR(K)
70 DO 80 I=1,16
J=D(I)
IF (J.EQ.0) J=10
80 DISPLY(I)=CHAR(J)
IF (SKIP.EQ.2) GO TO 100
IF (SKIP.EQ.1) GO TO 90
TYPE 2000, DP, L, EEX, M, FIXFLG, FIX, MVO, SCI, SUM, ERROR
TYPE 3000, P(6),SIGN(6),(X(6,N),N=2,14),ESN(6),X(6,16),
2 X(6,17),OP(6),P(5),SIGN(5),(X(5,N),N=2,14),
3 ESN(5),X(5,16),X(5,17),OP(5),P(4),SIGN(4),
4 (X(4,N),N=2,14),ESN(4),X(4,16),X(4,17),OP(4),
5 P(3),SIGN(3),(X(3,N),N=2,14),ESN(3),X(3,16),
6 X(3,17),OP(3)
90 TYPE 4000, P(2),SIGN(2),(X(2,N),N=2,14),ESN(2),X(2,16),
2 X(2,17),OP(2),P(1),SIGN(1),(X(1,N),N=2,14),
3 ESN(1),X(1,16),X(1,17),OP(1)
100 TYPE 5000, DISPLY
IF (SKIP.EQ.2) RETURN
DO 120 I=2,4
IF (R(I,2).EQ.15) GO TO 120
DO 110 J=1,17
K=R(I,J)
IF (K.EQ.0) K=10
110 REG(J)=CHAR(K)
TYPE 6000, NAME(I-1), (REG(N), N=1,17)
120 CONTINUE
DO 140 I=5,20
IF (R(I,2).EQ.15) GO TO 140
J=I-5
DO 130 K=1,17
KK=R(I,K)
IF (KK.EQ.0) KK=10
130 REG(K)=CHAR(KK)
TYPE 7000, J, (REG(N), N=1,17)
140 CONTINUE
RETURN
1000 FORMAT (/6X,'EXPRESSION: ',39A3/30X,11A3)
2000 FORMAT (//14X,'FLAGS: DP -',L2,20X,'INDICES: L -',
2 I2/22X,'EEX -',L2,30X,'M -',I2/22X,
3 'FIXFLG-',L2,30X,'FIX -',I2/22X,'MVO -',L2,30X,
4 'SCI -',I2/22X,'SUM -',L2,30X,'ERROR -',I2)
3000 FORMAT (//14X,'STACK: S(6) -',4X,I2,' / ',A2,I2,' .',12I2,
2 A2,2I2,' /',I3/22X,'S(5) -',4X,I2,' / ',A2,I2,' .',
3 12I2,A2,2I2,' /',I3/22X,'S(4) -',4X,I2,' / ',A2,I2,
4 ' .',12I2,A2,2I2,' /',I3/22X,'S(3) -',4X,I2,' / ',
5 A2,I2,' .',12I2,A2,2I2,' /',I3)
4000 FORMAT (/22X,'S(2) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,' /',
2 I3/22X,'S(1) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,
3 ' /',I3/)
5000 FORMAT (/14X,'DISPLAY:',9X,16A3///)
6000 FORMAT (15X,A8,1X,2A3,' .',15A3)
7000 FORMAT (14X,'REG(',I2,') =',1X,2A3,' .',15A3)
END
SUBROUTINE UPDATE
C DATE OF LAST CHANGE - 740209
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (X(1,2).GT.15) RETURN
D(1)=X(1,1)
IF (D(1).EQ.14) D(1)=15
D(2)=X(1,2)
IF (X(1,2).EQ.15) D(2)=0
IF (.NOT.FIXFLG) GO TO 12
C DISPLAY IN "FIX" FORMAT
IF (X(1,16).GT.0) GO TO 12
EXPX=X(1,17)
IF (X(1,15).EQ.13) GO TO 5
K=EXPX+FIX+1
IF (K.GT.10) GO TO 12
DO 1 I=13,16
1 D(I)=15
CALL ROUND (K)
K=EXPX+2
DO 2 I=3,K
2 D(I)=W(I)
K=K+1
D(K)=11
IF (FIX.EQ.0) GO TO 4
DO 3 I=1,FIX
3 D(I+K)=W(I+K-1)
4 K=K+FIX+1
GO TO 15
5 D(2)=10
D(3)=11
K=FIX-EXPX+1
IF (K.LE.0) GO TO 8
CALL ROUND (K)
J=EXPX+2
DO 6 I=4,J
6 D(I)=10
DO 7 I=1,K
7 D(J+I)=W(I+1)
GO TO 10
8 J=FIX+3
DO 9 I=4,J
9 D(I)=10
10 K=FIX+4
DO 11 I=13,16
11 D(I)=15
GO TO 15
C DISPLAY IN "SCI" FORMAT
12 CALL ROUND (SCI)
D(13)=29
DO 13 I=14,16
13 D(I)=W(I+1)
D(3)=11
K=SCI+3
DO 14 I=5,K
14 D(I-1)=W(I-2)
15 DO 16 I=K,12
16 D(I)=15
RETURN
END
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE ROUND (N)
C DATE OF LAST CHANGE - 740209
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DO 1 I=1,17
1 W(I)=X(1,I)
IF (W(N+2)-5) 6,2,4
2 K=N+3
DO 3 I=K,14
IF (W(I).GT.0) GO TO 4
3 CONTINUE
K=N+1
IF (2*(W(K)/2) .EQ. W(K)) GO TO 6
4 K=N+1
W(K)=W(K)+1
DO 5 I=3,K
J=N+4-I
IF (W(J).LT.10) GO TO 6
W(J)=W(J)-10
5 W(J-1)=W(J-1)+1
6 RETURN
END
SUBROUTINE MESAGE
C DATE OF LAST CHANGE - 740620
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
NEXT=.FALSE.
D(1)=15
DO 1 I=2,16
1 D(I)=13
D(8)=29
D(9)=ERROR/10
D(10)=ERROR-10*D(9)
IF (ERROR.NE.17) GO TO 2
D(15)=CODE/10
D(16)=CODE-10*D(15)
2 CALL CONTRL (.TRUE.)
IF (CODE.EQ.26) GO TO 3
IF (CODE.NE.27) GO TO 5
CALL UPDATE
GO TO 4
3 CALL CLEAR
4 ERROR=0
5 RETURN
END
C
C
C
C
C
C
C
C
SUBROUTINE CONTRL (OUT)
C DATE OF LAST CHANGE - 740704
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT, OUT
DIMENSION INPUT(50), EXPR(50), R(21,17), W(17)
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (OUT) CALL OUTPUT (SWITCH)
IF (NEXT) RETURN
1 TYPE 3
ACCEPT 4, CODE
IF (CODE.NE.100) GO TO 2
CALL OUTPUT (0)
GO TO 1
2 KEY=KEY+1
EXPR(KEY)=CODE
IF (CODE.EQ.10) CODE=0
RETURN
3 FORMAT (' ?'/)
4 FORMAT (I)
END
SUBROUTINE RESET
C DATE OF LAST CHANGE - 740210
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
DIMENSION R(21,17), W(17)
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
L=1
M=1
DP=.FALSE.
EEX=.FALSE.
CALL UPDATE
RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE TESTUP (*)
C DATE OF LAST CHANGE - 740625
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16)
COMMON /STACK/ P, X, OP, D
IF (X(6,2).EQ.15) RETURN
IF (OP(2).LT.50) GO TO 1
IF (P(1).EQ.0) RETURN
1 ERROR=3
RETURN 1
END
C
C
C
C
C
C
C
C
C
SUBROUTINE ENTRUP
C DATE OF LAST CHANGE - 740630
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16)
COMMON /STACK/ P, X, OP, D
DO 1 I=1,5
J=6-I
K=J+1
P(K)=P(J)
OP(K)=OP(J)
DO 1 L=1,17
1 X(K,L)=X(J,L)
CALL CLEARS
RETURN
END
SUBROUTINE CLEARS
C DATE OF LAST CHANGE - 740310
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16)
COMMON /STACK/ P, X, OP, D
P(1)=0
CALL CLEARX
RETURN
END
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE DROP
C DATE OF LAST CHANGE - 740725
IMPLICIT INTEGER (A-Z)
LOGICAL MVO
DIMENSION P(6), X(6,17), OP(6), D(16)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
1 P(1)=P(2)
C USUALLY DROP 3 -> 2, ETC.; AFTER 'CLEAR X' DROP 2 -> 1, ETC.
J=2
IF (X(1,2).EQ.15) J=1
DO 2 I=J,5
JJ=I+1
P(I)=P(JJ)
OP(I)=OP(JJ)
DO 2 K=1,17
2 X(I,K)=X(JJ,K)
IF (OP(6).EQ.0) GO TO 4
OP(6)=0
P(6)=0
DO 3 I=1,17
3 X(6,I)=0
X(6,2)=15
4 IF (.NOT.MVO) RETURN
C IF AN "MVO" HAS JUST BEEN EXECUTED NEED MORE 'DROPS'
IF (OP(2).EQ.10) GO TO 1
MVO=.FALSE.
P(1)=P(1)-1
IF (X(2,1).NE.13) GO TO 1
SIGN=X(1,1)
IF (SIGN.EQ.13) X(1,1)=14
IF (SIGN.NE.13) X(1,1)=13
GO TO 1
END
SUBROUTINE SETUP (*)
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (X(1,2).EQ.15) RETURN
IF (OP(1).NE.0) GO TO 1
CALL TESTUP (&4)
OP(1)=50
CALL COLAPS (&4)
GO TO 5
1 IF (OP(1).NE.1) GO TO 2
CALL CLEARX
RETURN
2 IF (X(6,2).EQ.15) GO TO 5
3 ERROR=3
4 RETURN 1
5 CALL ENTRUP
RETURN
END
SUBROUTINE CLEAR
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
CALL CLEARS
DO 1 I=2,6
J=I-1
P(I)=P(J)
OP(I)=OP(J)
DO 1 K=1,17
1 X(I,K)=X(J,K)
RETURN
END
C
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE LPAREN
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (P(1).NE.4) GO TO 1
ERROR=2
RETURN
1 IF (X(1,2).NE.15) GO TO 2
IF (X(1,1).NE.13) GO TO 7
CALL TESTUP (&8)
X(1,2)=1
GO TO 3
2 IF (OP(1).NE.0) GO TO 4
CALL TESTUP (&8)
3 OP(1)=50
CALL COLAPS (&8)
GO TO 6
4 IF (OP(1).NE.1) GO TO 5
CALL CLEARX
GO TO 7
5 IF (X(6,2).EQ.15) GO TO 6
ERROR=3
RETURN
6 CALL ENTRUP
7 P(1)=P(1)+1
8 RETURN
END
SUBROUTINE RPAREN
C DATE OF LAST CHANGE - 740722
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (OP(1).LT.2) GO TO 2
1 ERROR=1
RETURN
2 DO 3 I=1,6
IF (P(I).NE.0) GO TO 4
3 CONTINUE
ERROR=4
RETURN
4 IF (P(1).NE.0) GO TO 7
IF (OP(2).EQ.0) GO TO 1
IF (OP(2).NE.10) GO TO 6
DO 5 I=3,6
IF (OP(I).NE.71) GO TO 5
PTR=I
GO TO 11
5 CONTINUE
GO TO 1
6 CALL EXECUT (2, &13)
GO TO 4
7 P(1)=P(1)-1
IF (P(1).NE.0) GO TO 12
IF (X(1,2).NE.15) GO TO 10
IF (OP(2).NE.50) GO TO 12
OP(2)=0
IF (X(2,2).NE.1) GO TO 9
DO 8 I=3,14
IF (X(2,I).NE.0) GO TO 9
8 CONTINUE
IF (X(2,16).NE.0) GO TO 9
IF (X(2,17).NE.0) GO TO 9
X(2,2)=15
9 CALL DROP
GO TO 12
10 IF (OP(2).NE.70) GO TO 12
11 CALL EXECUT (PTR, &13)
RETURN
12 CALL UPDATE
13 RETURN
END
SUBROUTINE EQUAL
C DATE OF LAST CHANGE - 740614
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (OP(1).EQ.0) GO TO 1
IF (OP(1).EQ.1) RETURN
ERROR=1
RETURN
1 DO 2 I=1,6
IF (P(I).EQ.0) GO TO 2
ERROR=4
RETURN
2 CONTINUE
IF (OP(2).EQ.0) GO TO 3
CALL EXECUT (2, &4)
GO TO 1
3 OP(1)=1
CALL UPDATE
4 RETURN
END
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE EXCH
C DATE OF LAST CHANGE - 740620
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16)
COMMON /STACK/ P, X, OP, D
DO 1 I=1,17
W=X(1,I)
X(1,I)=X(2,I)
1 X(2,I)=W
CALL UPDATE
RETURN
END
SUBROUTINE SEMI
C DATE OF LAST CHANGE - 740723
IMPLICIT INTEGER (A-Z)
LOGICAL MVO, SUM, IF
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DATA IF /.FALSE./
IF (.NOT.MVO) GO TO 3
C TREAT AS ARGUMENT SEPARATOR FOR "MVO"
DO 1 I=2,6
IF (OP(I).NE.71) GO TO 1
J=I-1
IF (P(J).EQ.1) GO TO 2
ERROR=4
RETURN
1 CONTINUE
2 CALL OPRATR
RETURN
3 IF (.NOT.SUM) GO TO 4
C TREAT AS ARGUMENT SEPARATOR FOR "SIGMA"
C- CALL SIGMA (3)
RETURN
4 IF (.NOT.IF) GO TO 5
C TREAT AS STRING SEPARATOR FOR "IF"
C- CALL IF (2)
C- RETURN
C TREAT AS GENERAL ARGUMENT SEPARATOR
5 IF (X(1,2).EQ.15) GO TO 6
IF (OP(1).LT.2) GO TO 7
6 ERROR=1
RETURN
7 OP(1)=10
RETURN
END
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE COMMA
C DATE OF LAST CHANGE - 740723
LOGICAL SUM
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
C- IF (SUM) CALL SIGMA (2)
RETURN
END
SUBROUTINE SIGN
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
IF (OP(1).NE.0) GO TO 2
IF (X(1,2).EQ.15) GO TO 4
1 OP(1)=CODE+17
CALL COLAPS (&5)
RETURN
2 IF (OP(1).EQ.1) GO TO 1
IF (X(6,2).EQ.15) GO TO 3
ERROR=3
RETURN
3 CALL ENTRUP
4 IF (CODE.NE.13) RETURN
IF (X(1,1).EQ.13) D(1)=15
IF (X(1,1).NE.13) D(1)=13
X(1,1)=D(1)
5 RETURN
END
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE OPRATR
C DATE OF LAST CHANGE - 740722
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (X(1,2).EQ.15) GO TO 1
IF (OP(1).LT.2) GO TO 2
1 ERROR=1
RETURN
2 IF (CODE.LT.19) OP(1)=CODE+24
IF (CODE.EQ.19) OP(1)=60
IF (CODE.EQ.36) OP(1)=10
IF (CODE.GT.39) OP(1)=CODE-20
CALL COLAPS (&3)
3 RETURN
END
SUBROUTINE FUNCTN
C DATE OF LAST CHANGE - 740722
IMPLICIT INTEGER (A-Z)
LOGICAL MVO
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
IF (CODE.EQ.44) MVO=.TRUE.
CALL SETUP (&2)
X(1,2)=CODE
D(1)=15
IF (.NOT.MVO) GO TO 1
OP(1)=71
RETURN
1 OP(1)=70
2 RETURN
END
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE IMEDEX
C DATE OF LAST CHANGE - 740306
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (OP(1).EQ.1) RETURN
IF (OP(1).EQ.0) GO TO 1
IF (X(1,2).EQ.15) GO TO 1
IF (OP(2).LT.20 .OR. OP(2).EQ.50) GO TO 2
1 ERROR=1
RETURN
2 OP(2)=OP(1)
IF (OP(1).EQ.70) CALL EXCH
CALL EXECUT (2, &3)
OP(1)=0
3 RETURN
END
SUBROUTINE COLAPS (*)
C DATE OF LAST CHANGE - 740306
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
1 IF (P(1).NE.0) RETURN
IF (OP(1)/10 .GT. OP(2)/10) RETURN
IF (OP(2).NE.0) GO TO 3
ERROR=18
2 RETURN 1
3 CALL EXECUT (2, &2)
GO TO 1
END
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE EXECUT (PTR, *)
C DATE OF LAST CHANGE - 740729
IMPLICIT INTEGER (A-Z)
LOGICAL MVO
DIMENSION P(6), X(6,17), OP(6), D(16),
* R(21,17), W(17), A(2,17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (OP(2).EQ.70) GO TO 4
C SAVE X(2,N) IN "LST X" & X(1,N) IN "LST Y"
DO 1 N=1,17
R(3,N)=X(2,N)
1 R(4,N)=X(1,N)
IF (OP(2).EQ.10) OP(2)=OP(PTR)+X(PTR,2)
C EXECUTE BINARY FUNCTION OR "MVO"
DO 2 I=1,2
DO 2 J=1,17
2 A(I,J)=X(I,J)
CALL COMBIN (A, OP(2), &7)
DO 3 I=1,17
3 X(1,I)=A(1,I)
GO TO 6
C SAVE X(1,N) IN "LST X", EXECUTE "SVO"
4 DO 5 I=1,17
5 R(3,I)=X(1,I)
IF (X(1,1).EQ.13) X(1,1)=14
IF (X(2,1).EQ.13) X(1,1)=13
6 CALL DROP
CALL UPDATE
RETURN
7 RETURN 1
END
SUBROUTINE COMBIN (A, OPER, *)
C DATE OF LAST CHANGE - 740716
C PURPOSE: EXECUTE "A(2,N) OPER A(1,N) → A(1,N)"
IMPLICIT INTEGER (A-Z)
REAL RX(2), X1, ALOG10, ABS, ALOG, EXP, E
DIMENSION A(2,17)
C CONVERT A(I,N) TO RX(I)
DO 2 I=1,2
RX(I)=A(I,14)
DO 1 J=1,12
K=14-J
1 RX(I)=0.1*RX(I)+A(I,K)
IF (A(I,1).EQ.13) RX(I)=-RX(I)
J=10*A(I,16)+A(I,17)
IF (J.GT.30) J=30
IF (A(I,15).EQ.13) J=-J
2 RX(I)=RX(I)*10.0**J
X1=RX(1)
C NOW EXECUTE RX(2), OPER, RX(1) -> RX(1)=X1
IF (OPER.GT.31) GO TO 3
IF (OPER.LT.30) GO TO 9
IF (OPER.EQ.30) X1=-X1
X1=RX(2)+X1
GO TO 15
3 IF (OPER.GT.50) GO TO 7
IF (OPER.EQ.40) GO TO 4
X1=RX(2)*X1
GO TO 15
4 IF (X1.GT.1.0E-30) GO TO 6
5 ERROR=7
RETURN 1
6 X1=RX(2)/X1
GO TO 15
7 IF (OPER.GT.60) GO TO 8
IF (RX(2).LE.0.0) GO TO 5
X1=X1*ALOG(RX(2))
IF (ABS(X1).GT.174) ERROR=8
IF (ABS(X1).GT.174.) X1=174.*X1/ABS(X1)
X1=EXP(X1)
GO TO 15
8 IF (OPER.LT.75) GO TO 5
X1=SQRT(X1*X1+RX(2)*RX(2))
GO TO 15
9 VALUE=0
OPER=OPER-19
GO TO (10,11,12,13), OPER
10 IF (RX(2) .EQ. X1) VALUE=1
GO TO 14
11 IF (RX(2) .NE. X1) VALUE=1
GO TO 14
12 IF (RX(2) .GT. X1) VALUE=1
GO TO 14
13 IF (RX(2) .LT. X1) VALUE=1
14 X1=VALUE
C EXTRACT EXPONENT, -> A(1,15), ..., A(1,17)
15 IF (X1.EQ.0.) GO TO 16
E=ALOG10(ABS(X1))+.00001
GO TO 17
16 K=0
GO TO 19
17 IF (E.GE.0.0) GO TO 18
K=-E+1
X1=X1*10.0**K
A(1,15)=13
GO TO 20
18 K=E
X1=X1/10.0**K
19 A(1,15)=14
20 A(1,16)=K/10
A(1,17)=K-10*A(1,16)
C CONVERT X1=RX(1) TO A(1,N), N=1, ..., 14
IF (X1.GE.0.0) GO TO 21
A(1,1)=13
X1=-X1
GO TO 22
21 A(1,1)=14
22 A(1,2)=X1
DO 23 I=3,14
J=I-1
X1=10.*(X1-A(1,J))
23 A(1,I)=X1
RETURN
END
SUBROUTINE CLEARX
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
OP(1)=0
C THIS STATEMENT IS NUMBERED FOR REFERENCE IN 'CORECT'
1 X(1,1)=15
X(1,2)=15
DO 2 I=3,17
2 X(1,I)=0
CALL RESET
RETURN
END
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE ADEXPD (*)
C DATE OF LAST CHANGE - 740717
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
C ADD EXPONENT OF D TO THAT OF X(1)
J=10*X(1,16)+X(1,17)
IF (X(1,15).EQ.13) J=-J
IF (D(15).EQ.15) D(15)=0
IF (D(16).EQ.15) D(16)=0
K=10*D(15)+D(16)
IF (D(14).EQ.13) K=-K
J=J+K
IF (J.GE.0) GO TO 1
J=-J
X(1,15)=13
GO TO 2
1 X(1,15)=14
2 X(1,16)=J/10
X(1,17)=J-X(1,16)*10
IF (X(1,16).LT.10) RETURN
ERROR=8
RETURN 1
END
SUBROUTINE ENTRY
C DATE OF LAST CHANGE - 740722
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, JUMP, NEXT
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
CALL SETUP (&10)
DO 1 I=2,16
1 D(I)=15
2 IF (CODE.GT.10) GO TO 3
CALL DIGIT
GO TO 11
3 IF (CODE.NE.11) GO TO 4
CALL DECPT
GO TO 11
4 IF (CODE.NE.12) GO TO 5
CALL ENTEXP
GO TO 11
5 IF (CODE.NE.28) GO TO 6
JUMP=.TRUE.
CALL CORECT
IF (.NOT.JUMP) GO TO 11
JUMP=.FALSE.
RETURN
6 IF (.NOT.EEX.OR.(CODE.NE.13.AND.CODE.NE.14)) GO TO 7
J=10*D(15)+D(16)
IF (J.NE.0 .AND. J.NE.165) GO TO 75
D(14)=CODE
GO TO 11
C? THIS GROUP GIVES ERROR IF COMMA ENTERED WITH DATA
7 IF (CODE.NE.37) GO TO 75
ERROR=1
RETURN
C? MAY WANT TO HAVE COMMA ACCEPTED AND DISPLAYED
75 IF (X(1,2).EQ.15) GO TO 8
IF (D(13).EQ.29) CALL ADEXPD (&10)
GO TO 9
8 X(1,2)=0
9 CALL RESET
NEXT=.TRUE.
10 RETURN
11 IF (ERROR.NE.0) RETURN
CALL CONTRL (.TRUE.)
GO TO 2
END
SUBROUTINE DIGIT
C DATE OF LAST CHANGE - 740630
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (.NOT.EEX) GO TO 1
D(15)=D(16)
D(16)=CODE
RETURN
1 IF (M.GT.14) RETURN
IF (DP) GO TO 2
IF (M.EQ.14) RETURN
2 M=M+1
D(M)=CODE
IF (L.GT.13) RETURN
IF (DP) GO TO 3
IF (L.EQ.1) GO TO 4
CALL EXPON (X(1,15),X(1,16),X(1,17),1)
GO TO 5
3 IF (L.NE.1) GO TO 5
CALL EXPON (X(1,15),X(1,16),X(1,17),-1)
4 IF (CODE.EQ.0) RETURN
5 L=L+1
X(1,L)=CODE
RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE EXPON (A,B,C,N)
C DATE OF LAST CHANGE - 740210
C ADD 'N' TO THE EXPONENT 'ABC' (I.E. SIGN, DIGIT, DIGIT)
IMPLICIT INTEGER (A-Z)
IF (B.EQ.15) B=0
IF (C.EQ.15) C=0
K=10*B+C
IF (A.EQ.13) K=-K
K=K+N
IF (K.GE.0) GO TO 1
K=-K
A=13
GO TO 2
1 A=14
2 B=K/10
C=K-10*B
RETURN
END
SUBROUTINE DECPT
C DATE OF LAST CHANGE - 740614
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (DP) GO TO 1
IF (.NOT.EEX) GO TO 3
1 CALL TESTUP (&4)
IF (D(13).EQ.29) CALL ADEXPD (&4)
OP(1)=50
CALL COLAPS (&4)
CALL ENTRUP
DO 2 I=2,16
2 D(I)=15
3 DP=.TRUE.
IF (M.GT.13) RETURN
M=M+1
D(M)=11
4 RETURN
END
C
C
C
C
C
C
SUBROUTINE ENTEXP
C DATE OF LAST CHANGE - 740712
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (.NOT.EEX) GO TO 1
CALL TESTUP (&2)
IF (D(13).EQ.29) CALL ADEXPD (&2)
OP(1)=50
CALL COLAPS (&2)
CALL ENTRUP
D(1)=15
X(1,1)=14
1 D(13)=29
D(14)=15
D(15)=0
D(16)=0
EEX=.TRUE.
IF (M.GT.1) RETURN
X(1,2)=1
L=2
D(2)=1
D(3)=11
M=3
DP=.TRUE.
2 RETURN
END
SUBROUTINE CORECT
C DATE OF LAST CHANGE - 740725
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP, JUMP
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (JUMP) GO TO 2
C START 2: TREATMENT FOR CALL FROM "LOOK-UP"
IF (OP(1).EQ.0) GO TO 1
IF (OP(1).NE.1) OP(1)=0
RETURN
1 IF (X(1,2).NE.15 .AND. D(3).NE.15) RETURN
C SHOULD ENTER "CLEARX" AT STATEMENT #1
CALL CLEARX
RETURN
C START 1: TREATMENT FOR CALL FROM "ENTRY"
2 JUMP=.FALSE.
IF (.NOT.EEX) GO TO 4
EEX=.FALSE.
DO 3 I=13,16
3 D(I)=15
RETURN
4 IF (M.GT.2) GO TO 6
IF (M.EQ.1) GO TO 5
IF (X(1,1).EQ.13) GO TO 6
C SHOULD ENTER "CLEARX" AT STATEMENT #1
5 CALL CLEARX
JUMP=.TRUE.
RETURN
6 IF (.NOT.DP) GO TO 8
IF (D(M).NE.11) GO TO 7
DP=.FALSE.
GO TO 11
7 IF (L.GT.2) GO TO 9
CALL EXPON (X(1,15),X(1,16),X(1,17),1)
IF (L.EQ.2) GO TO 10
IF (L.EQ.1) GO TO 11
GO TO 9
8 IF (L.EQ.1) GO TO 11
IF (L.EQ.2) GO TO 10
CALL EXPON (X(1,15),X(1,16),X(1,17),-1)
9 X(1,L)=0
L=L-1
GO TO 11
10 X(1,2)=15
L=L-1
11 D(M)=15
M=M-1
RETURN
END
SUBROUTINE RECALL
C DATE OF LAST CHANGE - 740614
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (CODE-24) 1, 2, 3
1 REGNO=-3
GO TO 5
2 REGNO=-4
GO TO 6
3 IF (CODE.EQ.25) GO TO 4
REGNO=CODE-40
GO TO 6
4 CALL REG (REGNO)
IF (ERROR.NE.0) RETURN
5 IF (R(REGNO+5,2).NE.15) GO TO 6
ERROR=6
RETURN
6 CALL SETUP (&10)
IF (X(1,1).EQ.13) GO TO 7
CALL TRANS (REGNO,.FALSE.)
GO TO 9
7 CALL TRANS (REGNO,.FALSE.)
IF (X(1,1).EQ.13) GO TO 8
X(1,1)=13
GO TO 9
8 X(1,1)=14
9 CALL UPDATE
10 RETURN
END
SUBROUTINE STORE
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17), OPCD(19), A(2,17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DATA OPCD /12*0, 30, 31, 0, 40, 41, 0, 60/
C?
C? SHOULD "→" BE ALLOWED AFTER AN OPERATOR? (YES)
C? IF (OP(1).GT.1) GO TO 65
C? CAN ELIMINATE THE STATEMENT NUMBER 65 (JUST THE NUMBER)
C?
KMAX=2
OPCODE=0
1 CALL FINDN (K,KMAX,REGNO)
IF (K.NE.0) GO TO 5
IF (CODE.NE.25) GO TO 2
CALL REG (REGNO)
IF (ERROR.NE.0) RETURN
GO TO 5
2 IF (CODE.NE.23) GO TO 3
REGNO=-3
NEXT=.FALSE.
GO TO 7
3 IF (CODE.EQ.13 .OR. CODE.EQ.14 .OR. CODE.EQ.16 .OR.
* CODE.EQ.17 .OR. CODE.EQ.19) GO TO 4
ERROR=1
RETURN
4 OPCODE=OPCD(CODE)
GO TO 1
5 IF (REGNO.LE.15) GO TO 6
ERROR=5
RETURN
6 IF (REGNO.GT.0 .OR. REGNO.EQ.-3) GO TO 7
65 ERROR=1
RETURN
C??
C?? SHOULD "→" BE TREATED AS "=→"? (NO)
C?? 7 IF (X(1,2).NE.15) CALL EQUAL
C?? IF (ERROR.NE.0) RETURN
C??
C? 7 OP(1)=1
C?
7 IF (OP(1).EQ.0) OP(1)=1
IF (OPCODE.EQ.0) GO TO 10
K=REGNO+5
DO 8 I=1,17
A(1,I)=X(1,I)
8 A(2,I)=R(K,I)
CALL COMBIN (A, OPCODE, &11)
DO 9 I=1,17
9 R(K,I)=A(1,I)
RETURN
10 CALL TRANS (REGNO,.TRUE.)
11 RETURN
END
SUBROUTINE REG (RN)
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IND=0
KMAX=2
1 CALL FINDN (K,KMAX,RN)
IF (K.NE.0) GO TO 5
IF (CODE.NE.25) GO TO 2
IF (IND.EQ.15) GO TO 6
IND=IND+1
GO TO 1
2 NEXT=.FALSE.
IF (CODE.NE.23) GO TO 3
RN=(R(2,2)+0.1*R(2,3))*10**R(2,17)
GO TO 5
3 IF (CODE.NE.22) GO TO 4
RN=16
OP(1)=1
GO TO 5
4 ERROR=9
RETURN
5 IF (RN.LE.16) GO TO 7
6 ERROR=5
RETURN
7 IF (IND.EQ.0) RETURN
RN=RN+5
IF (R(RN,2).EQ.15) GO TO 8
RN=(R(RN,2)+0.1*R(RN,3))*10**R(RN,17)
IND=IND-1
GO TO 5
8 ERROR=6
RETURN
END
SUBROUTINE FINDN (K, KMAX, RN)
C DATE OF LAST CHANGE - 740227
IMPLICIT INTEGER (A-Z)
INTEGER INPUT(50), EXPR(50)
LOGICAL NEXT
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
NEXT=.FALSE.
K=0
RN=0
1 CALL CONTRL (.FALSE.)
IF (CODE.GT.10) GO TO 4
K=K+1
KMAX=KMAX-1
IF (K.GT.1) GO TO 2
RN=CODE
GO TO 3
2 RN=10*RN+CODE
3 IF (KMAX.NE.0) GO TO 1
RETURN
4 NEXT=.TRUE.
RETURN
END
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE TRANS (REGNO, STORE)
C DATE OF LAST CHANGE - 740715
IMPLICIT INTEGER (A-Z)
LOGICAL STORE
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
K=REGNO+5
IF (STORE) GO TO 2
DO 1 I=1,17
1 X(1,I)=R(K,I)
RETURN
2 DO 3 I=1,17
3 R(K,I)=X(1,I)
IF (R(K,2).EQ.15) R(K,2)=0
IF (R(K,1).EQ.13 .AND. R(K,2).EQ.0) R(K,1)=15
RETURN
END
SUBROUTINE FIXN
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
DIMENSION INPUT(50), EXPR(50), R(21,17), W(17)
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
FIXFLG=.TRUE.
CALL NUMBER (&1)
FIX=CODE
CALL UPDATE
1 RETURN
END
C
C
C
C
C
C
C
C
C
SUBROUTINE SCIN
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
DIMENSION INPUT(50), EXPR(50), R(21,17), W(17)
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
FIXFLG=.FALSE.
CALL NUMBER (&1)
SCI=CODE+1
CALL UPDATE
1 RETURN
END
C
C
C
C
C
C
C
C
SUBROUTINE NUMBER (*)
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
DIMENSION INPUT(50), EXPR(50), R(21,17), W(17)
COMMON /FLAGS/ EEX, DP, JUMP, NEXT, FIXFLG, MVO, SUM
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
CALL CONTRL (.FALSE.)
IF (CODE.LT.11) RETURN
NEXT=.TRUE.
CALL UPDATE
RETURN 1
END